COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(eval-when (eval compile load)
C00007 ENDMK
C⊗;
(eval-when (eval compile load)
   (or (status feature COMPLR) (break ULUZ-RPG-GET-A-COMPLR))
   (and (status feature MACLISP) (setq obarray sobarray readtable creadtable))
)


(setq rod-DO '(do ((old 1 new)
		   (new 2 (1+ new))
		   (l () (cons (list old new) l))
		   (i 0 (1+ i)))
		  ((= i n) l)))
(defun TST-NIL () (macro-expand (DO-expander rod-DO)))
(defun TST-MACLISP () (macro-expand (p1do rod-DO)))


(defun DO-expander (xx)
    (prog (indxl endtst endval retval tg1 tg2 lvars stepdvars lvals 
	   body bdfp tem name do-only-once?)
	  (setq body (cond ((eq (car xx) 'DO-NAMED) 
			    (setq name (cadr xx))
			    (cddr xx))
			   ('T (cdr xx))))
	  (si:gen-local-var tg1)
	  (si:gen-local-var tg2)
	  (cond ((and (car body) (atom (car body)))	;old-style?
		 (let (((v i s e . b) body))
		      (setq indxl `((,v ,i ,s))
			    endtst e
			    body b
			    endval ())))
		('T (pop body indxl) 
		    (pop body endtst)
		    (cond 
		       ((null endtst) (setq do-only-once? 'T))
		       ((atom endtst) (setq bdfp 'T))
		       ('T (setq endval 
				 (cond ((atom (cdr endtst)) ())
				       ((and (null (cddr endtst))
					     (or (null (setq tem (macroexpand (cadr endtst))))
						 (and (not (atom tem))
						      (eq (car tem) 'QUOTE)
						      (not (atom (cdr tem)))
						      (null (cadr tem)))))
					'() )
				       ('T (reverse (cdr endtst))))
				 endtst (car endtst))))))
	  (setq endtst 
		(cond (endtst `((COND ((NOT ,endtst) (GO ,tg1)))))
		      (do-only-once? () )
		      ('T ;; ######## (if endval (warn xx |Dead clause in return value|))
			  `((GO ,tg1)))))
	  (if endval 
	      (setq retval (nreconc (cdr endval) `((RETURN ,(car endval))))))
	  (mapc '(lambda (x) 
		   (cond ((atom x) (push x lvars) (push () lvals))
			 ('T 
			  (push (car x) lvars)
			  (push (cond ((and (cdr x) (atom (cdr x)))
					  (setq bdfp 'T)
					  () )
				      ('T (cond ((cddr x)
						 (push (car x) stepdvars)
						 (push (caddr x) stepdvars)
						 (and (cdddr x) 
						      (setq bdfp 'T))))
					  (cadr x)))
				lvals)
			  (setq x (car x))))
		   (and (not (symbolp x)) (setq bdfp 'T)))
		indxl)
	  (cond (bdfp (error '|Bad DO format| xx)))
	  (setq lvars (nreverse lvars) lvals (nreverse lvals))
	  (return 
	   `((LAMBDA ,lvars 
		     ,.(and (not (atom (car body))) 
			    (eq (caar body) 'DECLARE)
			    (prog1 (ncons (car body)) (pop body)))
			(PROG () 
				  (GO ,tg2)
			   ,tg1	  ,@body
				  ,.(and stepdvars 
					 `((PSETQ ,.(nreverse stepdvars))))
			   ,tg2   ,.endtst 
				  ,.retval))
		,.lvals)) ))